home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / src / tclMain.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-05  |  9.4 KB  |  424 lines  |  [TEXT/MPS ]
  1. /* 
  2.  * main.c --
  3.  *
  4.  *    Main program for Tcl shells and other Tcl-based applications.
  5.  *
  6.  * Copyright (c) 1988-1993 The Regents of the University of California.
  7.  * All rights reserved.
  8.  *
  9.  * Permission is hereby granted, without written agreement and without
  10.  * license or royalty fees, to use, copy, modify, and distribute this
  11.  * software and its documentation for any purpose, provided that the
  12.  * above copyright notice and the following two paragraphs appear in
  13.  * all copies of this software.
  14.  * 
  15.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  16.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  17.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  18.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  19.  *
  20.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  21.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  22.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  23.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  24.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  25.  */
  26.  
  27. #ifndef lint
  28. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclMain.c,v 1.10 93/09/17 17:32:47 ouster Exp $ SPRITE (Berkeley)";
  29. #endif
  30.  
  31. #include "tclInt.h"
  32. #include "tclUnix.h"
  33.  
  34. #ifdef THINK_C
  35. #    include <console.h>
  36. #endif
  37.  
  38. static Tcl_Interp *interp;    /* Interpreter for application. */
  39. static Tcl_DString command;    /* Used to buffer incomplete commands being
  40.                  * read from stdin. */
  41. char *tcl_RcFileName = NULL;    /* Name of a user-specific startup script
  42.                  * to source if the application is being run
  43.                  * interactively (e.g. "~/.tclshrc").  Set
  44.                  * by Tcl_AppInit.  NULL means don't source
  45.                  * anything ever. */
  46. #ifdef TCL_MEM_DEBUG
  47. static char dumpFile[100];    /* Records where to dump memory allocation
  48.                  * information. */
  49. static int quitFlag = 0;    /* 1 means the "checkmem" command was
  50.                  * invoked, so the application should quit
  51.                  * and dump memory allocation information. */
  52. #endif
  53.  
  54. /*
  55.  * Forward references for procedures defined later in this file:
  56.  */
  57.  
  58. static int        CheckmemCmd _ANSI_ARGS_((ClientData clientData,
  59.                 Tcl_Interp *interp, int argc, char *argv[]));
  60.  
  61. /*
  62.  *----------------------------------------------------------------------
  63.  *
  64.  * main --
  65.  *
  66.  *    This is the main program for a Tcl-based shell that reads
  67.  *    Tcl commands from standard input.
  68.  *
  69.  * Results:
  70.  *    None.
  71.  *
  72.  * Side effects:
  73.  *    Can be almost arbitrary, depending on what the Tcl commands do.
  74.  *
  75.  *----------------------------------------------------------------------
  76.  */
  77.  
  78. #ifdef macintosh
  79.  
  80. char    **environ = NULL;
  81.  
  82. #endif
  83.  
  84.  
  85. int
  86. #ifdef MPW
  87.  
  88. main(argc, argv, envp)
  89.     int argc;                /* Number of arguments. */
  90.     char **argv;            /* Array of argument strings. */
  91.     char **envp;            /* Array of environment strings. */
  92.  
  93. #else
  94.  
  95. main(argc, argv)
  96.     int argc;                /* Number of arguments. */
  97.     char **argv;            /* Array of argument strings. */
  98.  
  99. #endif
  100. {
  101.     char buffer[1000], *cmd, *args, *fileName;
  102.     int code, gotPartial, tty;
  103.     int exitCode = 0;
  104.     
  105. #ifdef MPW
  106.     char    prompt_prefix[128];
  107. #endif
  108.  
  109. #ifdef THINK_C
  110.     console_options.pause_atexit = 0;
  111.     console_options.title = "\pTcl Shell";
  112.     printf("Macintosh Tcl Shell. Tcl version 7.0, with extensions.\n");
  113. #endif
  114.  
  115. #ifdef THINK_C
  116.     {
  117.     int        i;
  118.     char    buffer[1024];
  119.     
  120.     environ = (char **) ckalloc( 5 * sizeof(char *) );
  121.     if (environ == NULL)
  122.         {
  123.         fprintf(stderr, "could not malloc environ");
  124.         exit(1);
  125.         }
  126.  
  127.     i = 0;
  128.     
  129. #ifdef TCL_LIBRARY
  130.     sprintf(buffer, "TCL_LIBRARY=%s", TCL_LIBRARY);
  131.     environ[i] = ckalloc( strlen(buffer) + 1 );
  132.     strcpy(environ[i++], buffer);
  133. #endif
  134.  
  135. #ifdef THINK_C
  136.     environ[i++] = "THINK_VERSION=1";
  137. #endif
  138.  
  139.     environ[i] = NULL;
  140.     }
  141. #endif
  142.  
  143. #ifdef MPW
  144.     {
  145.     int        i;
  146.     char    *ptr;
  147.     
  148.     for ( i = 0 ; envp[i] != NULL ; i++ )
  149.         ;
  150.     
  151.     environ = (char **) ckalloc( (i + 2) * sizeof(char *) );
  152.     if (environ == NULL)
  153.         {
  154.         fprintf(stderr, "could not malloc environ");
  155.         exit(1);
  156.         }
  157.     
  158.     for ( i = 0 ; envp[i] != NULL ; i++ )
  159.         {
  160.         for ( ptr = envp[i] ; *ptr++ ; )
  161.             ;
  162.  
  163.         environ[i] = ckalloc( strlen(envp[i]) + strlen(ptr) + 2 );
  164.  
  165.         strcpy(environ[i], envp[i]);
  166.         strcat(environ[i], "=");
  167.         strcat(environ[i], ptr);
  168.         }
  169.     
  170.     environ[i] = NULL;
  171.     }
  172. #endif
  173.  
  174.     interp = Tcl_CreateInterp();
  175.     
  176. #ifdef TCL_MEM_DEBUG
  177.     Tcl_InitMemory(interp);
  178.     Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
  179.                             (Tcl_CmdDeleteProc *) NULL);
  180. #endif
  181.  
  182.     /*
  183.      * Make command-line arguments available in the Tcl variables "argc"
  184.      * and "argv".  If the first argument doesn't start with a "-" then
  185.      * strip it off and use it as the name of a script file to process.
  186.      */
  187.  
  188.     fileName = NULL;
  189.     if ((argc > 1) && (argv[1][0] != '-'))
  190.         {
  191.         fileName = argv[1];
  192.         argc--;
  193.         argv++;
  194.         }
  195.     args = Tcl_Merge(argc-1, argv+1);
  196.     Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
  197.     ckfree(args);
  198.     sprintf(buffer, "%d", argc-1);
  199.     Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
  200.     Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
  201.                 TCL_GLOBAL_ONLY);
  202.  
  203.     /*
  204.      * Set the "tcl_interactive" variable.
  205.      */
  206.  
  207.     tty = isatty(0);
  208.     Tcl_SetVar(interp, "tcl_interactive",
  209.         ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
  210.  
  211.     /*
  212.      * Invoke application-specific initialization.
  213.      */
  214.  
  215.     if (Tcl_AppInit(interp) != TCL_OK)
  216.         {
  217.         fprintf(stderr, "Tcl_AppInit failed: %s\n", interp->result);
  218.         }
  219.  
  220.     /*
  221.      * If a script file was specified then just source that file
  222.      * and quit.
  223.      */
  224.  
  225.     if (fileName != NULL) {
  226.     code = Tcl_EvalFile(interp, fileName);
  227.     if (code != TCL_OK) {
  228.         fprintf(stderr, "%s\n", interp->result);
  229.         exitCode = 1;
  230.     }
  231.     goto done;
  232.     }
  233.  
  234.     /*
  235.      * We're running interactively.  Source a user-specific startup
  236.      * file if Tcl_AppInit specified one and if the file exists.
  237.      */
  238.  
  239.     if (tcl_RcFileName != NULL) {
  240.     Tcl_DString buffer;
  241.     char *fullName;
  242.  
  243.     fullName = Tcl_TildeSubst(interp, tcl_RcFileName, &buffer);
  244.     if (fullName == NULL) {
  245.         fprintf(stderr, "%s\n", interp->result);
  246.     } else {
  247.         if (access(fullName, R_OK) == 0) {
  248.         code = Tcl_EvalFile(interp, fullName);
  249.         if (code != TCL_OK) {
  250.             fprintf(stderr, "%s\n", interp->result);
  251.         }
  252.         }
  253.     }
  254.     Tcl_DStringFree(&buffer);
  255.     }
  256.  
  257.     /*
  258.      * Process commands from stdin until there's an end-of-file.
  259.      */
  260.  
  261.     gotPartial = 0;
  262.     Tcl_DStringInit(&command);
  263.     while (1)
  264.     {
  265.     clearerr(stdin);
  266.     if (tty)
  267.         {
  268.         char *promptCmd;
  269.  
  270.         promptCmd = Tcl_GetVar( interp,
  271.                                 (gotPartial ? "tcl_prompt2" : "tcl_prompt1"),
  272.                                 TCL_GLOBAL_ONLY );
  273.         if (promptCmd == NULL)
  274.             {
  275. defaultPrompt:
  276.             if (! gotPartial)
  277.                 {
  278.                 fputs("% ", stdout);
  279. #ifdef MPW
  280.                 strcpy(prompt_prefix, "% ");
  281. #endif
  282.                 }
  283.             }
  284.         else
  285.             {
  286.             code = Tcl_Eval(interp, promptCmd);
  287.             if (code != TCL_OK)
  288.                 {
  289.                 fprintf(stderr, "%s\n", interp->result);
  290.                 Tcl_AddErrorInfo(interp,
  291.                     "\n    (script that generates prompt)");
  292.                 goto defaultPrompt;
  293.                 }
  294. #ifdef MPW
  295.             else
  296.                 {
  297.                 strcpy(prompt_prefix, interp->result);
  298.                 }
  299. #endif
  300.             }
  301.         fflush(stdout);
  302.         }
  303.         
  304.     if (fgets(buffer, 1000, stdin) == NULL)
  305.         {
  306.         if (ferror(stdin))
  307.             {
  308.             if (errno == EINTR)
  309.                 {
  310.                 if (tcl_AsyncReady)
  311.                     {
  312.                     (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0);
  313.                     }
  314.                 clearerr(stdin);
  315.                 }
  316.             else
  317.                 {
  318.                 goto done;
  319.                 }
  320.             }
  321.         else
  322.             {
  323.             if (!gotPartial)
  324.                 {
  325.                 goto done;
  326.                 }
  327.             }
  328.         buffer[0] = 0;
  329.         }
  330.     
  331. #ifdef MPW
  332.     {
  333.     int        plen, blen;
  334.     
  335.     blen = strlen(buffer);
  336.     plen = strlen(prompt_prefix);
  337.     
  338.     if ( blen > plen && strncmp( buffer, prompt_prefix, plen ) == 0 )
  339.         {
  340.         memmove( buffer, &buffer[ plen ], ( blen - plen ) );
  341.         buffer[ blen - plen ] = '\0';
  342.         }
  343.     }
  344. #endif
  345.  
  346.     cmd = Tcl_DStringAppend(&command, buffer, -1);
  347.     if ((buffer[0] != 0) && !Tcl_CommandComplete(cmd))
  348.         {
  349.         gotPartial = 1;
  350.         continue;
  351.         }
  352.  
  353.     gotPartial = 0;
  354.     code = Tcl_RecordAndEval(interp, cmd, 0);
  355.     Tcl_DStringFree(&command);
  356.     if (code != TCL_OK)
  357.         {
  358.         fprintf(stderr, "%s\n", interp->result);
  359.         }
  360.     else if (tty && (*interp->result != 0))
  361.         {
  362.         printf("%s\n", interp->result);
  363.         }
  364. #ifdef TCL_MEM_DEBUG
  365.     if (quitFlag)
  366.         {
  367.         Tcl_DeleteInterp(interp);
  368.         Tcl_DumpActiveMemory(dumpFile);
  369.         exit(0);
  370.         }
  371. #endif
  372.     }
  373.  
  374.     /*
  375.      * Rather than calling exit, invoke the "exit" command so that
  376.      * users can replace "exit" with some other command to do additional
  377.      * cleanup on exit.  The Tcl_Eval call should never return.
  378.      */
  379.  
  380.     done:
  381.     sprintf(buffer, "exit %d", exitCode);
  382.     Tcl_Eval(interp, buffer);
  383.     return 1;
  384. }
  385.  
  386. /*
  387.  *----------------------------------------------------------------------
  388.  *
  389.  * CheckmemCmd --
  390.  *
  391.  *    This is the command procedure for the "checkmem" command, which
  392.  *    causes the application to exit after printing information about
  393.  *    memory usage to the file passed to this command as its first
  394.  *    argument.
  395.  *
  396.  * Results:
  397.  *    Returns a standard Tcl completion code.
  398.  *
  399.  * Side effects:
  400.  *    None.
  401.  *
  402.  *----------------------------------------------------------------------
  403.  */
  404. #ifdef TCL_MEM_DEBUG
  405.  
  406.     /* ARGSUSED */
  407. static int
  408. CheckmemCmd(clientData, interp, argc, argv)
  409.     ClientData clientData;        /* Not used. */
  410.     Tcl_Interp *interp;            /* Interpreter for evaluation. */
  411.     int argc;                /* Number of arguments. */
  412.     char *argv[];            /* String values of arguments. */
  413. {
  414.     if (argc != 2) {
  415.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  416.         " fileName\"", (char *) NULL);
  417.     return TCL_ERROR;
  418.     }
  419.     strcpy(dumpFile, argv[1]);
  420.     quitFlag = 1;
  421.     return TCL_OK;
  422. }
  423. #endif
  424.